home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / loop.lisp < prev    next >
Encoding:
Text File  |  1992-12-10  |  24.9 KB  |  826 lines
  1. ;;; -*- Package: LOOP -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: loop.lisp,v 1.8 91/05/24 19:37:33 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: loop.lisp,v 1.8 91/05/24 19:37:33 wlott Exp $
  15. ;;;
  16. ;;; Loop facility, written by William Lott.
  17. ;;; 
  18. (in-package "LOOP")
  19.  
  20. (in-package "LISP")
  21. (export '(loop loop-finish))
  22.  
  23. (in-package "LOOP")
  24.  
  25.  
  26. ;;;; Specials used during the parse.
  27.  
  28. ;;; These specials hold the different parts of the result as we are generating
  29. ;;; them.
  30. ;;; 
  31. (defvar *loop-name*)
  32. (defvar *outside-bindings*)
  33. (defvar *prologue*)
  34. (defvar *inside-bindings*)
  35. (defvar *body-forms*)
  36. (defvar *iteration-forms*)
  37. (defvar *epilogue*)
  38. (defvar *result-var*)
  39. (defvar *return-value*)
  40. (defvar *default-return-value*)
  41. (defvar *accumulation-variables*)
  42.  
  43. ;;; This special holds the remaining stuff we need to parse.
  44. ;;; 
  45. (defvar *remaining-stuff*)
  46.  
  47. ;;; This special holds a value that is EQ only to itself.
  48. ;;; 
  49. (defvar *magic-cookie* (list '<magic-cookie>))
  50.  
  51.  
  52. ;;;; Utility functions/macros used by the parser.
  53.  
  54. (proclaim '(inline maybe-car maybe-cdr))
  55.  
  56. (defun maybe-car (thing)
  57.   (if (consp thing) (car thing) thing))
  58.  
  59. (defun maybe-cdr (thing)
  60.   (if (consp thing) (cdr thing) thing))
  61.  
  62.  
  63. (defmacro loop-keyword-p (thing keyword &rest more-keywords)
  64.   `(let ((thing ,thing))
  65.      (and (symbolp thing)
  66.       (let ((name (symbol-name thing)))
  67.         (or ,@(mapcar #'(lambda (keyword)
  68.                   `(string= name ,keyword))
  69.               (cons keyword more-keywords)))))))
  70.  
  71. (defun preposition-p (prep)
  72.   (when (loop-keyword-p (car *remaining-stuff*) prep)
  73.     (pop *remaining-stuff*)
  74.     t))
  75.  
  76.  
  77. (defun splice-in-subform (form subform)
  78.   (if (eq form *magic-cookie*)
  79.       subform
  80.       (labels ((sub-splice-in-subform (form path)
  81.          (cond ((atom form)
  82.             nil)
  83.                ((member form path)
  84.             nil)
  85.                ((eq (car form) *magic-cookie*)
  86.             (setf (car form) subform)
  87.             t)
  88.                (t
  89.             (let ((new-path (cons form path)))
  90.               (or (sub-splice-in-subform (car form) new-path)
  91.                   (sub-splice-in-subform (cdr form) new-path)))))))
  92.     (if (sub-splice-in-subform form nil)
  93.         form
  94.         (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken."
  95.            form)))))
  96.  
  97. (defmacro queue-var (where name type &key
  98.                (initer nil initer-p) (stepper nil stepper-p))
  99.   `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper)
  100.      ,where))
  101.  
  102. (defvar *default-values* '(nil 0 0.0)
  103.   "The different possible default values.  When we need a default value, we
  104.   use the first value in this list that is typep the desired type.")
  105.  
  106. (defun pick-default-value (var type)
  107.   (if (consp var)
  108.       (cons (pick-default-value (car var) (maybe-car type))
  109.         (pick-default-value (cdr var) (maybe-cdr type)))
  110.       (dolist (default *default-values*
  111.                (error "Cannot default variables of type ~S ~
  112.                        (for variable ~S)."
  113.                   type var))
  114.     (when (typep default type)
  115.       (return default)))))
  116.  
  117. (defun only-simple-types (type-spec)
  118.   (if (atom type-spec)
  119.       (member type-spec '(fixnum float t nil))
  120.       (and (only-simple-types (car type-spec))
  121.        (only-simple-types (cdr type-spec)))))
  122.  
  123.  
  124. (defun build-let-expression (vars)
  125.   (if (null vars)
  126.       (values *magic-cookie* *magic-cookie*)
  127.       (let ((inside nil)
  128.         (outside nil)
  129.         (steppers nil)
  130.         (sub-lets nil))
  131.     (dolist (var vars)
  132.       (labels
  133.           ((process (name type initial-p initial stepper-p stepper)
  134.              (cond ((atom name)
  135.             (cond ((not stepper-p)
  136.                    (push (list type name initial) outside))
  137.                   ((not initial-p)
  138.                    (push (list type name stepper) inside))
  139.                   (t
  140.                    (push (list type name initial) outside)
  141.                    (setf steppers
  142.                      (nconc steppers (list name stepper))))))
  143.                ((and (car name) (cdr name))
  144.             (let ((temp (gensym (format nil "TEMP-FOR-~A-" name))))
  145.               (process temp 'list initial-p initial
  146.                    stepper-p stepper)
  147.               (push (if stepper-p
  148.                     (list (car name)
  149.                       (maybe-car type)
  150.                       nil nil
  151.                       t `(car ,temp))
  152.                     (list (car name)
  153.                       (maybe-car type)
  154.                       t `(car ,temp)
  155.                       nil nil))
  156.                 sub-lets)
  157.               (push (if stepper-p
  158.                     (list (cdr name)
  159.                       (maybe-cdr type)
  160.                       nil nil
  161.                       t `(cdr ,temp))
  162.                     (list (car name)
  163.                       (maybe-cdr type)
  164.                       t `(cdr ,temp)
  165.                       nil nil))
  166.                 sub-lets)))
  167.                ((car name)
  168.             (process (car name)
  169.                  (maybe-car type)
  170.                  initial-p `(car ,initial)
  171.                  stepper-p `(car ,stepper)))
  172.                ((cdr name)
  173.             (process (cdr name)
  174.                  (maybe-cdr type)
  175.                  initial-p `(cdr ,initial)
  176.                  stepper-p `(cdr ,stepper))))))
  177.         (process (first var) (second var) (third var)
  178.              (fourth var) (fifth var) (sixth var))))
  179.     (when steppers
  180.       (push (cons 'psetq steppers)
  181.         *iteration-forms*))
  182.     (multiple-value-bind
  183.         (sub-outside sub-inside)
  184.         (build-let-expression sub-lets)
  185.       (values (build-bindings outside sub-outside)
  186.           (build-bindings inside sub-inside))))))
  187.  
  188. (defun build-bindings (vars guts)
  189.   (if (null vars)
  190.       guts
  191.       `(let ,(mapcar #'cdr vars)
  192.      (declare ,@(mapcar #'build-declare vars))
  193.      ,guts)))
  194.  
  195. (defun build-declare (var)
  196.   `(type ,(car var) ,(cadr var)))
  197.  
  198.  
  199.  
  200. ;;;; LOOP itself.
  201.  
  202. (defmacro loop (&rest stuff)
  203.   "General iteration facility.  See the manual for details, 'cause it's
  204.   very confusing."
  205.   (if (some #'atom stuff)
  206.       (parse-loop stuff)
  207.       (let ((repeat (gensym "REPEAT-"))
  208.         (out-of-here (gensym "OUT-OF-HERE-")))
  209.     `(block nil
  210.        (tagbody
  211.         ,repeat
  212.         (macrolet ((loop-finish () `(go ,out-of-here)))
  213.           ,@stuff)
  214.         (go ,repeat)
  215.         ,out-of-here)))))
  216.  
  217.  
  218.  
  219. ;;;; The parser.
  220.  
  221. ;;; Top level parser.  Bind the specials, and call the other parsers.
  222. ;;; 
  223. (defun parse-loop (stuff)
  224.   (let* ((*prologue* nil)
  225.      (*outside-bindings* *magic-cookie*)
  226.      (*inside-bindings* *magic-cookie*)
  227.      (*body-forms* nil)
  228.      (*iteration-forms* nil)
  229.      (*epilogue* nil)
  230.      (*result-var* nil)
  231.      (*return-value* nil)
  232.      (*default-return-value* nil)
  233.      (*accumulation-variables* nil)
  234.      (*remaining-stuff* stuff)
  235.      (name (parse-named)))
  236.     (loop
  237.       (when (null *remaining-stuff*)
  238.     (return))
  239.       (let ((clause (pop *remaining-stuff*)))
  240.     (cond ((not (symbolp clause))
  241.            (error "Invalid clause, ~S, must be a symbol." clause))
  242.           ((loop-keyword-p clause "INITIALLY")
  243.            (setf *prologue* (nconc *prologue* (parse-expr-list))))
  244.           ((loop-keyword-p clause "FINALLY")
  245.            (parse-finally))
  246.           ((loop-keyword-p clause "WITH")
  247.            (parse-with))
  248.           ((loop-keyword-p clause "FOR" "AS")
  249.            (parse-for-as))
  250.           ((loop-keyword-p clause "REPEAT")
  251.            (parse-repeat))
  252.           (t
  253.            (push clause *remaining-stuff*)
  254.            (return)))))
  255.     (loop
  256.       (when (null *remaining-stuff*)
  257.     (return))
  258.       (let ((clause (pop *remaining-stuff*)))
  259.     (cond ((not (symbolp clause))
  260.            (error "Invalid clause, ~S, must be a symbol." clause))
  261.           ((loop-keyword-p clause "INITIALLY")
  262.            (setf *prologue* (nconc *prologue* (parse-expr-list))))
  263.           ((loop-keyword-p clause "FINALLY")
  264.            (parse-finally))
  265.           ((loop-keyword-p clause "WHILE")
  266.            (setf *body-forms*
  267.              (nconc *body-forms*
  268.                 `((unless ,(pop *remaining-stuff*)
  269.                 (loop-finish))))))
  270.           ((loop-keyword-p clause "UNTIL")
  271.            (setf *body-forms*
  272.              (nconc *body-forms*
  273.                 `((when ,(pop *remaining-stuff*) (loop-finish))))))
  274.           ((loop-keyword-p clause "ALWAYS")
  275.            (setf *body-forms*
  276.              (nconc *body-forms*
  277.                 `((unless ,(pop *remaining-stuff*)
  278.                 (return-from ,name nil)))))
  279.            (setf *default-return-value* t))
  280.           ((loop-keyword-p clause "NEVER")
  281.            (setf *body-forms*
  282.              (nconc *body-forms*
  283.                 `((when ,(pop *remaining-stuff*)
  284.                 (return-from ,name nil)))))
  285.            (setf *default-return-value* t))
  286.           ((loop-keyword-p clause "THEREIS")
  287.            (setf *body-forms*
  288.              (nconc *body-forms*
  289.                 (let ((temp (gensym "THEREIS-")))
  290.                   `((let ((,temp ,(pop *remaining-stuff*)))
  291.                   (when ,temp
  292.                     (return-from ,name ,temp))))))))
  293.           (t
  294.            (push clause *remaining-stuff*)
  295.            (or (maybe-parse-unconditional)
  296.            (maybe-parse-conditional)
  297.            (maybe-parse-accumulation)
  298.            (error "Unknown clause, ~S" clause))))))
  299.     (let ((again-tag (gensym "AGAIN-"))
  300.       (end-tag (gensym "THIS-IS-THE-END-")))
  301.       `(block ,name
  302.      ,(splice-in-subform
  303.        *outside-bindings*
  304.        `(macrolet ((loop-finish () '(go ,end-tag)))
  305.           (tagbody
  306.            ,@*prologue*
  307.            ,again-tag
  308.            ,(splice-in-subform
  309.          *inside-bindings*
  310.          `(progn
  311.             ,@*body-forms*
  312.             ,@(nreverse *iteration-forms*)))
  313.            (go ,again-tag)
  314.            ,end-tag
  315.            ,@*epilogue*
  316.            (return-from ,name
  317.                 ,(or *return-value*
  318.                  *default-return-value*
  319.                  *result-var*)))))))))
  320.  
  321. (defun parse-named ()
  322.   (when (loop-keyword-p (car *remaining-stuff*) "NAMED")
  323.     (pop *remaining-stuff*)
  324.     (if (symbolp (car *remaining-stuff*))
  325.     (pop *remaining-stuff*)
  326.     (error "Loop name ~S is not a symbol." (car *remaining-stuff*)))))
  327.  
  328.  
  329. (defun parse-expr-list ()
  330.   (let ((results nil))
  331.     (loop
  332.       (when (atom (car *remaining-stuff*))
  333.     (return (nreverse results)))
  334.       (push (pop *remaining-stuff*) results))))
  335.  
  336. (defun parse-finally ()
  337.   (let ((sub-clause (pop *remaining-stuff*)))
  338.     (if (loop-keyword-p sub-clause "RETURN")
  339.     (cond ((not (null *return-value*))
  340.            (error "Cannot specify two FINALLY RETURN clauses."))
  341.           ((null *remaining-stuff*)
  342.            (error "FINALLY RETURN must be followed with an expression."))
  343.           (t
  344.            (setf *return-value* (pop *remaining-stuff*))))
  345.     (progn
  346.       (unless (loop-keyword-p sub-clause "DO" "DOING")
  347.         (push sub-clause *remaining-stuff*))
  348.       (setf *epilogue* (nconc *epilogue* (parse-expr-list)))))))
  349.  
  350. (defun parse-with ()
  351.   (let ((vars nil))
  352.     (loop
  353.       (multiple-value-bind (var type) (parse-var-and-type-spec)
  354.     (let ((initial
  355.            (if (loop-keyword-p (car *remaining-stuff*) "=")
  356.            (progn
  357.              (pop *remaining-stuff*)
  358.              (pop *remaining-stuff*))
  359.            (list 'quote
  360.              (pick-default-value var type)))))
  361.       (queue-var vars var type :initer initial)))
  362.       (if (loop-keyword-p (car *remaining-stuff*) "AND")
  363.       (pop *remaining-stuff*)
  364.       (return)))
  365.     (multiple-value-bind
  366.     (outside inside)
  367.     (build-let-expression vars)
  368.       (setf *outside-bindings*
  369.         (splice-in-subform *outside-bindings* outside))
  370.       (setf *inside-bindings*
  371.         (splice-in-subform *inside-bindings* inside)))))
  372.  
  373. (defun parse-var-and-type-spec ()
  374.   (values (pop *remaining-stuff*)
  375.       (parse-type-spec t)))
  376.  
  377. (defun parse-type-spec (default)
  378.   (cond ((preposition-p "OF-TYPE")
  379.      (pop *remaining-stuff*))
  380.     ((and *remaining-stuff*
  381.           (only-simple-types (car *remaining-stuff*)))
  382.      (pop *remaining-stuff*))
  383.     (t
  384.      default)))
  385.  
  386.  
  387.  
  388. ;;;; FOR/AS stuff.
  389.  
  390. ;;; These specials hold the vars that need to be bound for this FOR/AS clause
  391. ;;; and all of the FOR/AS clauses connected with AND.  All the *for-as-vars*
  392. ;;; are bound in parallel followed by the *for-as-sub-vars*.
  393. ;;; 
  394. (defvar *for-as-vars*)
  395. (defvar *for-as-sub-vars*)
  396.  
  397. ;;; These specials hold any extra termination tests.  *for-as-term-tests* are
  398. ;;; processed after the *for-as-vars* are bound, but before the
  399. ;;; *for-as-sub-vars*.  *for-as-sub-term-tests* are processed after the
  400. ;;; *for-as-sub-vars*.
  401.  
  402. (defvar *for-as-term-tests*)
  403. (defvar *for-as-sub-term-tests*)
  404.  
  405.  
  406. (defun parse-for-as ()
  407.   (let ((*for-as-vars* nil)
  408.     (*for-as-term-tests* nil)
  409.     (*for-as-sub-vars* nil)
  410.     (*for-as-sub-term-tests* nil))
  411.     (loop
  412.       (multiple-value-bind (name type) (parse-var-and-type-spec)
  413.     (let ((sub-clause (pop *remaining-stuff*)))
  414.       (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM"
  415.                  "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE")
  416.          (parse-arithmetic-for-as sub-clause name type))
  417.         ((loop-keyword-p sub-clause "IN")
  418.          (parse-in-for-as name type))
  419.         ((loop-keyword-p sub-clause "ON")
  420.          (parse-on-for-as name type))
  421.         ((loop-keyword-p sub-clause "=")
  422.          (parse-equals-for-as name type))
  423.         ((loop-keyword-p sub-clause "ACROSS")
  424.          (parse-across-for-as name type))
  425.         ((loop-keyword-p sub-clause "BEING")
  426.          (parse-being-for-as name type))
  427.         (t
  428.          (error "Invalid FOR/AS subclause: ~S" sub-clause)))))
  429.       (if (loop-keyword-p (car *remaining-stuff*) "AND")
  430.       (pop *remaining-stuff*)
  431.       (return)))
  432.     (multiple-value-bind
  433.     (outside inside)
  434.     (build-let-expression *for-as-vars*)
  435.       (multiple-value-bind
  436.       (sub-outside sub-inside)
  437.       (build-let-expression *for-as-sub-vars*)
  438.     (setf *outside-bindings*
  439.           (splice-in-subform *outside-bindings*
  440.                  (splice-in-subform outside sub-outside)))
  441.     (let ((inside-body
  442.            (if *for-as-term-tests*
  443.            `(if (or ,@(nreverse *for-as-term-tests*))
  444.             (loop-finish)
  445.             ,*magic-cookie*)
  446.            *magic-cookie*))
  447.           (sub-inside-body
  448.            (if *for-as-sub-term-tests*
  449.            `(if (or ,@(nreverse *for-as-sub-term-tests*))
  450.             (loop-finish)
  451.             ,*magic-cookie*)
  452.            *magic-cookie*)))
  453.       (setf *inside-bindings*
  454.         (splice-in-subform
  455.          *inside-bindings*
  456.          (splice-in-subform
  457.           inside
  458.           (splice-in-subform
  459.            inside-body
  460.            (splice-in-subform
  461.             sub-inside
  462.             sub-inside-body))))))))))
  463.  
  464. (defun parse-arithmetic-for-as (sub-clause name type)
  465.   (unless (atom name)
  466.     (error "Cannot destructure arithmetic FOR/AS variables: ~S" name))
  467.   (let (start stop (inc 1) dir exclusive-p)
  468.     (cond ((loop-keyword-p sub-clause "FROM")
  469.        (setf start (pop *remaining-stuff*)))
  470.       ((loop-keyword-p sub-clause "DOWNFROM")
  471.        (setf start (pop *remaining-stuff*))
  472.        (setf dir :down))
  473.       ((loop-keyword-p sub-clause "UPFROM")
  474.        (setf start (pop *remaining-stuff*))
  475.        (setf dir :up))
  476.       (t
  477.        (push sub-clause *remaining-stuff*)))
  478.     (cond ((preposition-p "TO")
  479.        (setf stop (pop *remaining-stuff*)))
  480.       ((preposition-p "DOWNTO")
  481.        (setf stop (pop *remaining-stuff*))
  482.        (if (eq dir :up)
  483.            (error "Can't mix UPFROM and DOWNTO in ~S." name)
  484.            (setf dir :down)))
  485.       ((preposition-p "UPTO")
  486.        (setf stop (pop *remaining-stuff*))
  487.        (if (eq dir :down)
  488.            (error "Can't mix DOWNFROM and UPTO in ~S." name)
  489.            (setf dir :up)))
  490.       ((preposition-p "ABOVE")
  491.        (setf stop (pop *remaining-stuff*))
  492.        (setf exclusive-p t)
  493.        (if (eq dir :up)
  494.            (error "Can't mix UPFROM and ABOVE in ~S." name)
  495.            (setf dir :down)))
  496.       ((preposition-p "BELOW")
  497.        (setf stop (pop *remaining-stuff*))
  498.        (setf exclusive-p t)
  499.        (if (eq dir :down)
  500.            (error "Can't mix DOWNFROM and BELOW in ~S." name)
  501.            (setf dir :up))))
  502.     (when (preposition-p "BY")
  503.       (setf inc (pop *remaining-stuff*)))
  504.     (when (and (eq dir :down) (null start))
  505.       (error "No default starting value for decremental stepping."))
  506.     (let ((temp (gensym "TEMP-AMOUNT-")))
  507.       (queue-var *for-as-sub-vars* temp type :initer inc)
  508.       (queue-var *for-as-sub-vars* name type
  509.          :initer (or start 0)
  510.          :stepper `(,(if (eq dir :down) '- '+) ,name ,temp))
  511.       (when stop
  512.     (let ((stop-var (gensym "STOP-VAR-")))
  513.       (queue-var *for-as-sub-vars* stop-var type :initer stop)
  514.       (push (list (if (eq dir :down)
  515.               (if exclusive-p '<= '<)
  516.               (if exclusive-p '>= '>))
  517.               name stop-var)
  518.         *for-as-sub-term-tests*))))))
  519.  
  520. (defun parse-in-for-as (name type)
  521.   (let* ((temp (gensym "LIST-"))
  522.      (initer (pop *remaining-stuff*))
  523.      (stepper (if (preposition-p "BY")
  524.               `(funcall ,(pop *remaining-stuff*) ,temp)
  525.               `(cdr ,temp))))
  526.     (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper)
  527.     (queue-var *for-as-sub-vars* name type :stepper `(car ,temp))
  528.     (push `(null ,temp) *for-as-sub-term-tests*)))
  529.  
  530. (defun parse-on-for-as (name type)
  531.   (let* ((temp (if (atom name) name (gensym "LIST-")))
  532.      (initer (pop *remaining-stuff*))
  533.      (stepper (if (preposition-p "BY")
  534.               `(funcall ,(pop *remaining-stuff*) ,temp)
  535.               `(cdr ,temp))))
  536.     (cond ((atom name)
  537.        (queue-var *for-as-sub-vars* name type
  538.               :initer initer :stepper stepper)
  539.        (push `(endp ,name) *for-as-sub-term-tests*))
  540.       (t
  541.        (queue-var *for-as-vars* temp type
  542.               :initer initer :stepper stepper)
  543.        (queue-var *for-as-sub-vars* name type :stepper temp)
  544.        (push `(endp ,temp) *for-as-term-tests*)))))
  545.  
  546. (defun parse-equals-for-as (name type)
  547.   (let ((initer (pop *remaining-stuff*)))
  548.     (if (preposition-p "THEN")
  549.     (queue-var *for-as-sub-vars* name type
  550.            :initer initer :stepper (pop *remaining-stuff*))
  551.     (queue-var *for-as-vars* name type :stepper initer))))
  552.  
  553. (defun parse-across-for-as (name type)
  554.   (let* ((temp (gensym "VECTOR-"))
  555.      (length (gensym "LENGTH-"))
  556.      (index (gensym "INDEX-")))
  557.     (queue-var *for-as-vars* temp `(vector ,type)
  558.            :initer (pop *remaining-stuff*))
  559.     (queue-var *for-as-sub-vars* length 'fixnum
  560.            :initer `(length ,temp))
  561.     (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index))
  562.     (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index))
  563.     (push `(>= ,index ,length) *for-as-term-tests*)))
  564.  
  565. (defun parse-being-for-as (name type)
  566.   (let ((clause (pop *remaining-stuff*)))
  567.     (unless (loop-keyword-p clause "EACH" "THE")
  568.       (error "BEING must be followed by either EACH or THE, not ~S"
  569.          clause)))
  570.   (let ((clause (pop *remaining-stuff*)))
  571.     (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS"
  572.                 "HASH-VALUE" "HASH-VALUES")
  573.        (let ((prep (pop *remaining-stuff*)))
  574.          (unless (loop-keyword-p prep "IN" "OF")
  575.            (error "~A must be followed by either IN or OF, not ~S"
  576.               (symbol-name clause) prep)))
  577.        (let ((table (pop *remaining-stuff*))
  578.          (iterator (gensym (format nil "~A-ITERATOR-" name)))
  579.          (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
  580.          (key-temp (gensym (format nil "~A-KEY-TEMP-" name)))
  581.          (value-temp (gensym (format nil "~A-VALUE-TEMP-" name))))
  582.          (setf *outside-bindings*
  583.            (splice-in-subform
  584.             *outside-bindings*
  585.             `(with-hash-table-iterator (,iterator ,table)
  586.                            ,*magic-cookie*)))
  587.          (multiple-value-bind
  588.          (using using-type)
  589.          (when (preposition-p "USING")
  590.            ;; ### This is wrong.
  591.            (parse-var-and-type-spec))
  592.            (multiple-value-bind
  593.            (key-var key-type value-var value-type)
  594.            (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS")
  595.                (values name type using using-type)
  596.                (values using using-type name type))
  597.          (setf *inside-bindings*
  598.                (splice-in-subform
  599.             *inside-bindings*
  600.             `(multiple-value-bind
  601.                  (,exists-temp ,key-temp ,value-temp)
  602.                  (,iterator)
  603.                ,@(unless (and key-var value-var)
  604.                    `((declare (ignore ,@(if (null key-var)
  605.                             (list key-temp))
  606.                           ,@(if (null value-var)
  607.                             (list value-temp))))))
  608.                ,*magic-cookie*)))
  609.          (push `(not ,exists-temp) *for-as-term-tests*)
  610.          (when key-var
  611.            (queue-var *for-as-sub-vars* key-var key-type
  612.                   :stepper key-temp))
  613.          (when value-var
  614.            (queue-var *for-as-sub-vars* value-var value-type
  615.                   :stepper value-temp))))))
  616.       ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
  617.                "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
  618.        (let ((package
  619.           (if (or (preposition-p "IN")
  620.               (preposition-p "OF"))
  621.               (pop *remaining-stuff*)
  622.               '*package*))
  623.          (iterator (gensym (format nil "~A-ITERATOR-" name)))
  624.          (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
  625.          (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name))))
  626.          (setf *outside-bindings*
  627.            (splice-in-subform
  628.             *outside-bindings*
  629.             `(with-package-iterator
  630.              (,iterator
  631.               ,package
  632.               ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS")
  633.                    '(:internal :external :inherited))
  634.                   ((loop-keyword-p clause "PRESENT-SYMBOL"
  635.                            "PRESENT-SYMBOLS")
  636.                    '(:internal))
  637.                   ((loop-keyword-p clause "EXTERNAL-SYMBOL"
  638.                            "EXTERNAL-SYMBOLS")
  639.                    '(:external))
  640.                   (t
  641.                    (error "Don't know how to deal with ~A?  ~
  642.                            Bug in LOOP?" clause))))
  643.                ,*magic-cookie*)))
  644.          (setf *inside-bindings*
  645.            (splice-in-subform
  646.             *inside-bindings*
  647.             `(multiple-value-bind
  648.              (,exists-temp ,symbol-temp)
  649.              (,iterator)
  650.                ,*magic-cookie*)))
  651.          (push `(not ,exists-temp) *for-as-term-tests*)
  652.          (queue-var *for-as-sub-vars* name type :stepper symbol-temp)))
  653.       (t
  654.        (error
  655.         "Unknown sub-clause, ~A, for BEING.  Must be one of:~%  ~
  656.          HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~%  ~
  657.          PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS"
  658.         (symbol-name clause))))))
  659.  
  660.  
  661.  
  662. ;;;;
  663.  
  664. (defun parse-repeat ()
  665.   (let ((temp (gensym "REPEAT-")))
  666.     (setf *outside-bindings*
  667.       (splice-in-subform *outside-bindings*
  668.                  `(let ((,temp ,(pop *remaining-stuff*)))
  669.                 ,*magic-cookie*)))
  670.     (setf *inside-bindings*
  671.       (splice-in-subform *inside-bindings*
  672.                  `(if (minusp (decf ,temp))
  673.                   (loop-finish)
  674.                   ,*magic-cookie*)))))
  675.  
  676.  
  677. (defun maybe-parse-unconditional ()
  678.   (when (loop-keyword-p (car *remaining-stuff*) "DO" "DOING")
  679.     (pop *remaining-stuff*)
  680.     (setf *body-forms* (nconc *body-forms* (parse-expr-list)))
  681.     t))
  682.  
  683. (defun maybe-parse-conditional ()
  684.   (let ((clause (pop *remaining-stuff*)))
  685.     (cond ((loop-keyword-p clause "IF" "WHEN")
  686.        (parse-conditional (pop *remaining-stuff*))
  687.        t)
  688.       ((loop-keyword-p clause "UNLESS")
  689.        (parse-conditional `(not ,(pop *remaining-stuff*)))
  690.        t)
  691.       (t
  692.        (push clause *remaining-stuff*)
  693.        nil))))
  694.  
  695. (defun parse-conditional (condition)
  696.   (let ((clauses (parse-and-clauses))
  697.     (else-clauses (when (preposition-p "ELSE")
  698.             (parse-and-clauses))))
  699.     (setf *body-forms*
  700.       (nconc *body-forms*
  701.          `((if ,condition
  702.                (progn
  703.              ,@clauses)
  704.                (progn
  705.              ,@else-clauses)))))
  706.     (preposition-p "END")))
  707.  
  708. (defun parse-and-clauses ()
  709.   (let ((*body-forms* nil))
  710.     (loop
  711.       (or (maybe-parse-unconditional)
  712.       (maybe-parse-conditional)
  713.       (maybe-parse-accumulation)
  714.       (error "Invalid clause for inside a conditional: ~S"
  715.          (car *remaining-stuff*)))
  716.       (unless (preposition-p "AND")
  717.     (return *body-forms*)))))
  718.  
  719.  
  720. ;;;; Assumulation stuff
  721.  
  722. (defun maybe-parse-accumulation ()
  723.   (when (loop-keyword-p (car *remaining-stuff*)
  724.                "COLLECT" "COLLECTING"
  725.                "APPEND" "APPENDING" "NCONC" "NCONCING"
  726.                "COUNT" "COUNTING" "SUM" "SUMMING"
  727.                "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")
  728.     (parse-accumulation)
  729.     t))
  730.  
  731. (defun parse-accumulation ()
  732.   (let* ((clause (pop *remaining-stuff*))
  733.      (expr (pop *remaining-stuff*))
  734.      (var (if (preposition-p "INTO")
  735.           (pop *remaining-stuff*)
  736.           (or *result-var*
  737.               (setf *result-var*
  738.                 (gensym (concatenate 'simple-string
  739.                          (string clause)
  740.                          "-"))))))
  741.      (info (assoc var *accumulation-variables*))
  742.      (type nil)
  743.      (initial nil))
  744.     (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING"
  745.                "NCONC" "NCONCING")
  746.        (setf initial nil)
  747.        (setf type 'list)
  748.        (let ((aux-var
  749.           (or (caddr info)
  750.               (let ((aux-var (gensym "LAST-")))
  751.             (setf *outside-bindings*
  752.                   (splice-in-subform *outside-bindings*
  753.                          `(let ((,var nil)
  754.                             (,aux-var nil))
  755.                             (declare (type list
  756.                                    ,var
  757.                                    ,aux-var))
  758.                             ,*magic-cookie*)))
  759.             (if (null info)
  760.                 (push (setf info (list var 'list aux-var))
  761.                   *accumulation-variables*)
  762.                 (setf (cddr info) (list aux-var)))
  763.             aux-var)))
  764.          (value
  765.           (cond ((loop-keyword-p clause "COLLECT" "COLLECTING")
  766.              `(list ,expr))
  767.             ((loop-keyword-p clause "APPEND" "APPENDING")
  768.              `(copy-list ,expr))
  769.             ((loop-keyword-p clause "NCONC" "NCONCING")
  770.              expr)
  771.             (t
  772.              (error "Bug in loop?")))))
  773.          (setf *body-forms*
  774.            (nconc *body-forms*
  775.               `((cond ((null ,var)
  776.                    (setf ,var ,value)
  777.                    (setf ,aux-var (last ,var)))
  778.                   (t
  779.                    (nconc ,aux-var ,value)
  780.                    (setf ,aux-var (last ,aux-var)))))))))
  781.       ((loop-keyword-p clause "COUNT" "COUNTING")
  782.        (setf type (parse-type-spec 'unsigned-byte))
  783.        (setf initial 0)
  784.        (setf *body-forms*
  785.          (nconc *body-forms*
  786.             `((when ,expr (incf ,var))))))
  787.       ((loop-keyword-p clause "SUM" "SUMMING")
  788.        (setf type (parse-type-spec 'number))
  789.        (setf initial 0)
  790.        (setf *body-forms*
  791.          (nconc *body-forms*
  792.             `((incf ,var ,expr)))))
  793.       ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING")
  794.        (setf type `(or null ,(parse-type-spec 'number)))
  795.        (setf initial nil)
  796.        (setf *body-forms*
  797.          (nconc *body-forms*
  798.             (let ((temp (gensym "MAX-TEMP-")))
  799.               `((let ((,temp ,expr))
  800.                   (when (or (null ,var)
  801.                     (> ,temp ,var))
  802.                 (setf ,var ,temp))))))))
  803.       ((loop-keyword-p clause "MINIMIZE" "MINIMIZING")
  804.        (setf type `(or null ,(parse-type-spec 'number)))
  805.        (setf initial nil)
  806.        (setf *body-forms*
  807.          (nconc *body-forms*
  808.             (let ((temp (gensym "MIN-TEMP-")))
  809.               `((let ((,temp ,expr))
  810.                   (when (or (null ,var)
  811.                     (< ,temp ,var))
  812.                 (setf ,var ,temp))))))))
  813.       (t
  814.        (error "Invalid accumulation clause: ~S" clause)))
  815.     (cond (info
  816.        (unless (equal type (cadr info))
  817.          (error "Attempt to use ~S for both types ~S and ~S."
  818.             var type (cadr info))))
  819.       (t
  820.        (push (list var type) *accumulation-variables*)
  821.        (setf *outside-bindings*
  822.          (splice-in-subform *outside-bindings*
  823.                     `(let ((,var ,initial))
  824.                        (declare (type ,type ,var))
  825.                        ,*magic-cookie*)))))))
  826.